home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / Modes / calc.tcl < prev    next >
Encoding:
Text File  |  2000-06-29  |  14.8 KB  |  544 lines
  1. ######################################################################
  2. #                                                                    #
  3. #   Use at your own risk. This is just a quick-and-dirty RPN stack   #
  4. #   calculator, works on both decimal (signed and unsigned), hex     #
  5. #   integers, and floating point. I put it                           #
  6. #   together for my own use, not yours, but feel free to use it as   #
  7. #   long as you don't complain about what it doesn't do.             #
  8. #   Improvements, of course, are welcome.                            #
  9. #                                                                    #
  10. #   Operations: Top of stack is 'y', next is 'x'.                    #
  11. #       ~               bitwise NOT                                  #
  12. #       +,-,*,/,|,&,%   Does x OP y.                                 #
  13. #       ^               x eor y or                                   #
  14. #                       x^y in floating point mode                   #
  15. #       <               x << y                                       #
  16. #       >               x >> y                                       #
  17. #       -  <z>         insert - sign                                 #
  18. #       n              change y's sign                               #
  19. #       q              dup y                                         #
  20. #       i              swap x and y                                  #
  21. #       m              switch decimal/hex modes                      #
  22. #       x              show current mode                             #
  23. #       h,?            help                                          #
  24. #       <backspace>    pop stack                                     #
  25. #       <space>        enter number                                  #
  26. #                                                                    #
  27. #   Floating point extensions                                        #
  28. #                                                                    #
  29. #       f <o>          floor(y)                                      #
  30. #       f <so>         ceil(y)                                       #
  31. #                                                                    #
  32. #       f <oz>         fmod(x,y)                                     #
  33. #       h <oz>         hypot(x,y)                                    #
  34. #       p <oz>         x**y                                          #
  35. #       s <oz>         sqrt(y)                                       #
  36. #                                                                    #
  37. #       l <z>          log(y)                                        #
  38. #       l <sz>         exp(y)                                        #
  39. #       l <oz>         log10(y)                                      #
  40. #                                                                    #
  41. #       c <o>          cos(y)                                        #
  42. #       s <o>          sin(y)                                        #
  43. #       t <o>          tan(y)                                        #
  44. #                                                                    #
  45. #       c <so>         acos(y)                                       #
  46. #       s <so>         asin(y)                                       #
  47. #       t <so>         atan(y)                                       #
  48. #                                                                    #
  49. #       c <z>          cosh(y)                                       #
  50. #       s <z>          sinh(y)                                       #
  51. #       t <z>          tanh(y)                                       #
  52. #                                                                    #
  53. #       c <sz>         acosh(y)                                      #
  54. #       s <sz>         asinh(y)                                      #
  55. #       t <sz>         atanh(y)                                      #
  56. #                                                                    #
  57. #       t <oz>         atan2(x,y)                                    #
  58. #                                                                    #
  59. #   The mode indicator indicates whether hex or dec is active.       #
  60. #   All calculations performed in signed decimal.                    #
  61. #                                                                    #
  62. ######################################################################
  63.  
  64. alpha::mode Calc 0.1.6 Calc::dummy {} {calcMenu} {
  65.     # Alpha will shift this in and out of global scope as necessary
  66.     newPref variable tcl_precision 17 Calc
  67.     # Set display precision in Calc mode.
  68.     newPref variable displayPrec 6 Calc
  69.       
  70.     addMenu calcMenu "Calc" Calc
  71. } help {file "Calculator Help"}
  72.  
  73. proc Calc::dummy {} {}
  74.  
  75. proc calcMenu {} {}
  76.  
  77. # Vince moved this here to avoid having calc.tcl sourced
  78. # at every startup.  It works fine here anyway.
  79. hook::register keyboard calcSwitchKeyboard
  80.  
  81. proc calculator {} {
  82.     global tileLeft tileTop calcMode
  83.     if {[set ind [lsearch -exact [winNames] {* Calc *}]] >= 0} {
  84.     bringToFront {* Calc *}
  85.     return
  86.     }
  87.     set calcMode 3
  88.     calcbind 1
  89.     new -g $tileLeft $tileTop 200 300 -n {* Calc *} -m Calc -shell 1
  90.     calcMenuEnable $calcMode
  91. }
  92.  
  93. ascii 0x2b "binop +"        Calc
  94. ascii 0x2d "binop -"        Calc
  95. ascii 0x2a "binop *"        Calc
  96. ascii 0x2f "binop /"        Calc
  97. ascii 0x5e "binop ^"        Calc
  98. ascii 0x26 "binop &"        Calc
  99. ascii 0x25 "binop %"        Calc
  100. ascii 0x3e "binop >>"        Calc
  101. ascii 0x3c "binop <<"        Calc
  102. ascii 0x7c "binop |"        Calc
  103. ascii 0x3f {edit -r -c [file join $HOME Help {Calculator Help}]} Calc
  104. ascii 0x68 {edit -r -c [file join $HOME Help {Calculator Help}]} Calc
  105. ascii 0x71 calcDup        Calc
  106. ascii 0x69 calcEx        Calc
  107. ascii 0x6d changeCalcMode    Calc
  108. ascii 0x78 "calcShow"        Calc
  109. ascii 0x20 calcEnter        Calc
  110. ascii 0x08 calcDel        Calc
  111. ascii 0x25 "function %"        Calc
  112. ascii 0x5e "function ^"        Calc
  113. ascii 0x6e "unaryop -"            Calc
  114. ascii 0x7e "unaryop ~"        Calc
  115.  
  116. #=============================================================================
  117. #
  118. # Calculator Menu:
  119. #
  120. #=============================================================================
  121. Menu -n Calc -p calcMenuProc -M Calc {
  122.     "!qduplicateY"
  123.     "!iswapXY"
  124.     "!mchangeMode"
  125.     "!xshowMode"
  126.     "(-"    
  127.     "!nnegate"
  128.     "/-<BinsertMinus"
  129.     "!%mod"
  130.     "(-"    
  131.     {Menu -n Boolean -p CalcBooleanItem -M Calc {
  132.     "!&and"
  133.     "!|or"
  134.     "!^xor"
  135.     "(-"    
  136.     "!<shiftLeft"
  137.     "!>shiftRight"
  138.     "!~not"                                  
  139.     }}
  140.     {Menu -n ExpAndLog -p CalcMenuItem -M Calc {
  141.     "/L<B<Uexp"
  142.     "/L<Blog"
  143.     "/L<B<Ilog10"                                  
  144.     }}
  145.     {Menu -n Trigonometric -p CalcMenuItem -M Calc {
  146.     "/C<Icos"
  147.     "/S<Isin"
  148.     "/T<Itan"
  149.     "(-"    
  150.     "/C<I<Uacos"
  151.     "/S<I<Uasin"
  152.     "/T<I<Uatan"         
  153.     }}
  154.     {Menu -n Hyperbolic -p CalcMenuItem -M Calc {
  155.     "/C<Bcosh"
  156.     "/S<Bsinh"
  157.     "/T<Btanh"
  158.     "(-"    
  159.     "/C<B<Uach"
  160.     "/S<B<Uash"
  161.     "/T<B<Uath"
  162.      }}
  163.     {Menu -n OtherMathFunctions -p calcMenuProc -M Calc {
  164.     "/F<Ifloor"  
  165.     "/F<I<Uceil"               
  166.     "(-"
  167.     "/T<B<Iatan2" 
  168.     "/F<B<I!%fmod"
  169.     "/H<B<Ihypot"
  170.     "/P<B<I!^pow"
  171.     "/S<B<Isqrt"
  172.     }}
  173.     {Menu -n Constants -p calcMenuProc -M Calc {
  174.     "/E<I<Ue"  
  175.     "/P<Ipi"               
  176.     }}
  177.     "(-"    
  178.     "!?calculatorHelp"
  179. }
  180.  
  181. Bind '-' <z>    { typeText "-" }        Calc
  182.  
  183. Bind 'f' <o>    "unaryop floor"             Calc
  184. Bind 'f' <os>    "unaryop ceil"              Calc
  185. Bind 'f' <oz>    "function fmod"             Calc
  186. Bind 'h' <oz>    "function hypot"        Calc
  187. Bind 'p' <oz>    "function pow"              Calc
  188. Bind 's' <oz>    "unaryop sqrt"            Calc
  189.  
  190. Bind 'l' <z>    "unaryop log"            Calc
  191. Bind 'l' <sz>    "unaryop exp"            Calc
  192. Bind 'l' <oz>    "unaryop log10"             Calc
  193.  
  194. Bind 'c' <o>    "unaryop cos"            Calc
  195. Bind 's' <o>    "unaryop sin"            Calc
  196. Bind 't' <o>    "unaryop tan"            Calc
  197. Bind 'c' <os>    "unaryop acos"              Calc
  198. Bind 's' <os>    "unaryop asin"              Calc
  199. Bind 't' <os>    "unaryop atan"              Calc
  200. Bind 'c' <z>    "unaryop cosh"            Calc
  201. Bind 's' <z>    "unaryop sinh"            Calc
  202. Bind 't' <z>    "unaryop tanh"            Calc
  203. Bind 'c' <sz>    "unaryop ach"            Calc
  204. Bind 's' <sz>    "unaryop ash"            Calc
  205. Bind 't' <sz>    "unaryop ath"            Calc
  206. Bind 't' <oz>    "function atan2"        Calc
  207.  
  208. Bind 'p' <o>    "insertText {3.14159265358979323}" Calc
  209. Bind 'e' <so>   "insertText {2.718281828459045}"   Calc
  210.  
  211. proc CalcMenuItem {menu item} {                                 
  212.     unaryop $item 
  213. }                                                                         
  214.  
  215. proc calcMenuProc {menu item} {
  216.     switch $item {
  217.     duplicateY {
  218.         calcDup
  219.     }
  220.     swapXY {
  221.         calcEx
  222.     }
  223.     changeMode {
  224.         changeCalcMode
  225.     }
  226.     showMode {
  227.         calcShow
  228.     }
  229.     negate {
  230.         unaryop -
  231.     }
  232.     insertMinus {
  233.         typeText "-"
  234.     }
  235.     mod {
  236.         function "%"
  237.     }
  238.     sqrt {
  239.         unaryop sqrt
  240.     }
  241.     floor {
  242.         unaryop floor
  243.     }
  244.     ceil {
  245.         unaryop ceil
  246.     }
  247.     e {
  248.         insertText {2.718281828459045}
  249.     }
  250.     pi {
  251.         insertText {3.14159265358979323}
  252.     }
  253.     calculatorHelp {
  254.         global HOME
  255.         edit -r -c [file join $HOME Help {Calculator Help}]
  256.     }
  257.     default {
  258.         function $item
  259.     }
  260.     }
  261. }
  262.  
  263. proc CalcBooleanItem {menu item} {
  264.     switch $item {
  265.     and {
  266.         binop &
  267.     }
  268.     or {
  269.         binop |
  270.     }
  271.     xor {
  272.         binop ^
  273.     }
  274.     shiftLeft {
  275.         binop <<
  276.     }
  277.     shiftRight {
  278.         binop >>
  279.     }
  280.     not {
  281.         unaryop ~
  282.     }
  283.     }
  284. }
  285.  
  286. proc calcMenuEnable {arg} {
  287.     if {$arg == 3} {
  288.     set a "on"
  289.     set b "off"
  290.     } else {
  291.     set a "off"
  292.     set b "on"
  293.     }
  294.     enableMenuItem Calc Boolean $b
  295.     enableMenuItem Calc ExpAndLog $a
  296.     enableMenuItem Calc Trigonometric $a
  297.     enableMenuItem Calc Hyperbolic $a
  298.     enableMenuItem Calc OtherMathFunctions $a
  299.     enableMenuItem Calc Constants $a
  300. }
  301.  
  302. proc calcbind {flag {keys ""}} {
  303.     global keyboard
  304.     if {$flag == 0} {
  305.         set func "unbind"
  306.     } else {
  307.         set func "Bind"
  308.     } 
  309.     if {$keys == ""} {
  310.         set keys $keyboard
  311.     }
  312.     switch -- $keys {
  313.         "Canadian - CSA" -
  314.         "Canadian - ISO" {set key "'-' <o> "}
  315.         "Croatian" {
  316.             set key "'<' <so> "
  317.             set pro "{unaryop ~}"
  318.             catch "$func $key $pro Calc"
  319.             set key "'i' <o> "
  320.             set pro "{function ^}"
  321.             catch "$func $key $pro Calc"
  322.             set key "'ç' <o> "
  323.             catch "$func $key $pro Calc"
  324.             set key "0x2a <so> "
  325.         }
  326.         "Danish" {set key "'i' <o> "}
  327.         "Español - ISO" {set key "'1' <o> "}
  328.         "Finnish" -
  329.         "German" -
  330.         "Norwegian" -
  331.         "Spanish" -
  332.         "Swedish" -
  333.         "Swiss French" -
  334.         "Swiss German" {set key "'7' <o> "}
  335.         "Flemish" -
  336.         "French" -
  337.         "French - numerical" {set key "'l' <so> "}
  338.         "Italian" {set key "':' <o> "}
  339.         "Slovenian" {
  340.             set key "0x27 <o> "
  341.             set pro "{function ^}"
  342.             catch "$func $key $pro Calc"
  343.             set key "'æ' <so> "
  344.         }
  345.         default {return}
  346.     }
  347.     set pro "{binop |}"
  348.     catch "$func $key $pro Calc"
  349. }
  350.  
  351. proc calcSwitchKeyboard {} {
  352.     global oldkeyboard keyboard
  353.     calcbind 0 $oldkeyboard
  354.     calcbind 1
  355. }
  356.  
  357. proc changeCalcMode {} {
  358.     global calcMode
  359.     
  360.     goto [maxPos]
  361.     if {[pos::compare [getPos] > [minPos]]} {
  362.     if {[lookAt [pos::math [getPos] - 1]] != "\r"} calcEnter
  363.     set nums {}
  364.     set t ""
  365.     foreach n [split [getText [minPos] [pos::math [maxPos] - 1]] "\r"] {
  366.         lappend nums [calcGet $n]
  367.     }
  368.     set calcMode [expr {($calcMode + 1) % 4}]
  369.     foreach n $nums {
  370.         append t "[calcPut $n]\r"
  371.     }
  372.     replaceText [minPos] [maxPos] $t
  373.     } else {
  374.     set calcMode [expr {($calcMode + 1) % 4}]
  375.     }
  376.     calcShow
  377.     calcMenuEnable $calcMode
  378. }
  379.  
  380.  
  381. proc calcShow {} {
  382.     global calcMode
  383.     switch -- "$calcMode" {
  384.         0     {message "Signed decimal" }
  385.         1     {message "Unsigned decimal"}
  386.         2     {message "Unsigned hexadecimal"}
  387.         3     {message "Floating Point"}
  388.     }
  389. }
  390.  
  391.  
  392. proc calcGet {in} {
  393.     global calcMode
  394.  
  395.     switch -- "$calcMode" {
  396.         0    {scan $in "%d" num; return $num}
  397.         1    {scan $in "%u" num; return $num}
  398.         2    {scan $in "%x" num; return $num}
  399.         3    {scan $in "%g" num; return $num}
  400.     }
  401.     error "Bad hex num '$in'"
  402. }
  403.  
  404. proc calcPut {in} {
  405.     global CalcmodeVars calcMode 
  406.     set prec $CalcmodeVars(displayPrec)
  407.     
  408.     if {$prec < 0} {
  409.         set prec 0
  410.         set CalcmodeVars(displayPrec) $prec
  411.     }
  412.     if {$prec > 17} {
  413.         set prec 17
  414.         set CalcmodeVars(displayPrec) $prec
  415.     }
  416.  
  417.     if {$calcMode != 3} {
  418.         regexp {[0-9-]+} $in in
  419.     }
  420.     switch -- $calcMode {
  421.         0         {return [format "%25d" $in]}
  422.         1         {return [format "%25u" $in]}
  423.         2         {return [format "%25x" $in]}
  424.         3         {return [format "%25.${prec}g" $in]}
  425.     }
  426. }
  427.         
  428. proc binop {op} {
  429.     global calcMode
  430.     if {$calcMode == 3 && ($op == "&" || $op == "|" \
  431.                            || $op == "<<" || $op == ">>")} {
  432.     beep
  433.     message "${op} does not work in floating point mode"
  434.     return
  435.     }
  436.     goto [maxPos]
  437.     if {[lookAt [pos::math [getPos] - 1]] != "\r"} calcEnter
  438.     set pos [lineStart [getPos]]
  439.     set st_y [lineStart [pos::math $pos - 1]]
  440.     set st_x [lineStart [pos::math $st_y - 1]]
  441.     if {[pos::compare $st_y == $st_x]} { beep; return}
  442.     set res [eval expr {[calcGet [getText $st_x $st_y]] $op \
  443.             [calcGet [getText $st_y $pos]]}]
  444.     replaceText $st_x [maxPos] [calcPut $res] "\r"
  445. }
  446.  
  447. proc unaryop {op} {
  448.     global calcMode
  449.     if {$calcMode != 3 && $op != "-" && $op != "~"} {
  450.     beep
  451.     message "${op} works only in floating point mode"
  452.     return
  453.     } elseif {$calcMode == 3 && $op == "~"} {
  454.     beep
  455.     message "${op} does not work in floating point mode"
  456.     return
  457.     }
  458.     goto [maxPos]
  459.     
  460.     set pos [getPos]
  461.     set last [lineStart [pos::math [getPos] - 1]]
  462.     set yvar [calcGet [getText $last $pos]]
  463.     switch -- $op {
  464.     "ach"     {set res [eval expr "log($yvar+sqrt($yvar*$yvar-1))"]}
  465.     "ash"     {set res [eval expr "log($yvar+sqrt($yvar*$yvar+1))"]}
  466.     "ath"     {set res [eval expr "0.5*log((1+$yvar)/(1-$yvar))"]}
  467.     default {set res [eval expr "${op}($yvar)"]}
  468.     }
  469.     replaceText $last $pos [calcPut $res] "\r"
  470. }
  471.  
  472. proc function {op} {
  473.     global calcMode
  474.     if {$calcMode != 3} {
  475.     if { $op == "^" || $op == "%"} {
  476.         binop $op
  477.         return
  478.     }
  479.     beep
  480.     message "${op} works only in floating point mode"
  481.     return
  482.     }
  483.     if { $op == "^" } {set op "pow"}
  484.     if { $op == "%" } {set op "fmod"}
  485.     goto [maxPos]
  486.     if {[lookAt [pos::math [getPos] - 1]] != "\r"} calcEnter
  487.     set pos [lineStart [getPos]]
  488.     set st_y [lineStart [pos::math $pos - 1]]
  489.     set st_x [lineStart [pos::math $st_y - 1]]
  490.     if {[pos::compare $st_y == $st_x]} { beep; return}
  491.     set res [eval expr "${op}([calcGet [getText $st_x $st_y]],\
  492.       [calcGet [getText $st_y $pos]])"]
  493.     replaceText $st_x [maxPos] "[calcPut $res]\r"
  494. }
  495.  
  496. proc calcEx {} {
  497.     goto [maxPos]
  498.     if {[lookAt [pos::math [getPos] - 1]] != "\r"} calcEnter
  499.     set pos [lineStart [getPos]]
  500.     set st_y [lineStart [pos::math $pos - 1]]
  501.     set st_x [lineStart [pos::math $st_y - 1]]
  502.     if {[pos::compare $st_y == $st_x]} { beep; return}
  503.     replaceText $st_x [maxPos] "[getText $st_y $pos][getText $st_x $st_y]"
  504. }
  505.  
  506.  
  507. proc calcEnter {} {
  508.     global calcMode
  509.     goto [maxPos]
  510.     switch -- "$calcMode" {
  511.     0     {set ex {[0-9-]+$}}
  512.     1     {set ex {[0-9]+$}}
  513.     2     {set ex {[0-9a-f]+$}}
  514.     3     {set ex {[eE0-9.-]+$}}
  515.     } 
  516.     if {[regexp -- $ex [getText [lineStart [getPos]] [getPos]] num]} {
  517.     set num [calcGet $num]
  518.     replaceText [lineStart [getPos]] [getPos] [calcPut $num] "\r"
  519.     } else {
  520.     beep
  521.     beginningOfLine
  522.     killLine
  523.     }
  524. }
  525.  
  526. proc calcDel {} {
  527.     goto [maxPos]
  528.     if {[is::Eol [lookAt [pos::math [getPos] - 1]]]} {
  529.     deleteText [lineStart [pos::math [getPos] - 1]] [getPos]
  530.     } else {
  531.     backSpace
  532.     }
  533. }
  534.  
  535. proc calcDup {} {
  536.     goto [maxPos]
  537.     if {![is::Eol [lookAt [pos::math [getPos] - 1]]]} calcEnter
  538.     set to [lineStart [getPos]]
  539.     set from [lineStart [pos::math $to - 1]]
  540.     set t [getText $from $to]
  541.     insertText $t
  542. }
  543.  
  544.